Option Explicit
Private p&, token, dic
Function ParseJSON(JSON$, Optional key$ = "obj") As Object

    p = 1
    token = Tokenize(JSON)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    

    Set ParseJSON = dic
End Function
Function ParseObj(key$)


    Do: p = p + 1
    
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{":  ParseObj key
            Case "{"
                       If token(p + 1) = "}" Then
                           p = p + 1
                           dic.Add key, "null"
                       Else
                           ParseObj key
                       End If
                
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else:
                If token(p + 1) <> ":" Then
                    If dic.Exists(key) Then
                        dic.Item(key) = token(p)
                    Else
                        dic.Add key, token(p)
                    End If
                End If
        End Select
    Loop
    
    
End Function
Function ParseArr(key$)

    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else:
                If Not dic.Exists(key & ArrayID(e)) Then
                    dic.Add key & ArrayID(e), token(p)
                End If
        End Select
    Loop
    
End Function
Function Tokenize(s$)
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .Global = bGlobal
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = Pattern
    If .Test(s) Then
      Set m = .Execute(s)
      ReDim v(1 To m.Count)
      For Each n In m
        c = c + 1
        v(c) = n.Value
        If bGroup1Bias Then If Len(n.SubMatches(0)) Or n.Value = """""" Then v(c) = n.SubMatches(0)
      Next
    End If
  End With
  RExtract = v
End Function
Function ArrayID$(e)
    ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function
Function GetFilteredValues(dic, match)
    Dim c&, i&, v, w
    v = dic.keys
    ReDim w(1 To dic.Count)
    For i = 0 To UBound(v)
        If v(i) Like match Then
            c = c + 1
            w(c) = dic(v(i))
        End If
    Next
    ReDim Preserve w(1 To c)
    GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
    Dim c&, i&, j&, v, w, z
    v = dic.keys
    z = GetFilteredValues(dic, cols(0))
    ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
    For j = 1 To UBound(cols) + 1
         z = GetFilteredValues(dic, cols(j - 1))
         For i = 1 To UBound(z)
            w(i, j) = z(i)
         Next
    Next
    GetFilteredTable = w
End Function
Function OpenTextFile$(f)
    With CreateObject("ADODB.Stream")
        .Charset = "utf-8"
        .Open
        .LoadFromFile f
        OpenTextFile = .ReadText
    End With
End Function

Sub mcrBuySell()
Dim x As Integer
Dim cStock As String
Dim nQty As Integer

    
    'Loop through column A and purchase any valid stock symbols with a quantity <> 0
    For x = 5 To 100
        cStock = ThisWorkbook.Sheets("Stocks").Range("A" + Trim(Str(x))).Value
        If Len(cStock) > 0 And Len(cStock) < 7 And _
            IsNumeric(ThisWorkbook.Sheets("Stocks").Range("C" + Trim(Str(x))).Value) Then
            nQty = ThisWorkbook.Sheets("Stocks").Range("C" + Trim(Str(x))).Value
            If nQty <> 0 Then
                MsgBox "Buy " + Trim(Str(nQty)) + " of " + cStock
                BuyItMarket cStock, nQty, x
            End If
        Else
            ThisWorkbook.Sheets("Stocks").Range("E" + Trim(Str(x))).Value = ""
        End If
    Next x

End Sub
Function BuyItMarket(cStock As String, nQty As Integer, nPosition As Integer)

Dim cAccountNumber As String
Dim cAccessToken As String
Dim cOS As String
Dim oHttp As Object
Dim httpGet As String
Dim cURL_EndPoint As String
Dim cPostData As String
    
    If Not GetTokens Then
        ThisWorkbook.Sheets("Stocks").Range("E" + Trim(Str(nPosition))).Value = "BUY ERROR!"
        Exit Function
    End If
    
    cAccountNumber = ThisWorkbook.Sheets("Settings").Range("B2").Value
    cAccessToken = ThisWorkbook.Sheets("Settings").Range("B3").Value

    If nQty > 0 Then
        
        cOS = cOS + "{" + Chr(10)
        cOS = cOS + "  " + Chr(34) + "orderType" + Chr(34) + ": " + Chr(34) + "MARKET" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "session" + Chr(34) + ": " + Chr(34) + "NORMAL" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "duration" + Chr(34) + ": " + Chr(34) + "DAY" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "orderStrategyType" + Chr(34) + ": " + Chr(34) + "SINGLE" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "orderLegCollection" + Chr(34) + ": [" + Chr(10)
        cOS = cOS + "    {" + Chr(10)
        cOS = cOS + "      " + Chr(34) + "instruction" + Chr(34) + ": " + Chr(34) + "BUY" + Chr(34) + "," + Chr(10)
        cOS = cOS + "      " + Chr(34) + "quantity" + Chr(34) + ": " + Trim(Str(nQty)) + "," + Chr(10)
        cOS = cOS + "      " + Chr(34) + "instrument" + Chr(34) + ": {" + Chr(10)
        cOS = cOS + "        " + Chr(34) + "symbol" + Chr(34) + ": " + Chr(34) + cStock + Chr(34) + "," + Chr(10)
        cOS = cOS + "        " + Chr(34) + "assetType" + Chr(34) + ": " + Chr(34) + "EQUITY" + Chr(34) + Chr(10)
        cOS = cOS + "      }" + Chr(10)
        cOS = cOS + "    }" + Chr(10)
        cOS = cOS + "  ]" + Chr(10)
        cOS = cOS + "}"
    Else
    
        cOS = cOS + "{" + Chr(10)
        cOS = cOS + "  " + Chr(34) + "orderType" + Chr(34) + ": " + Chr(34) + "MARKET" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "session" + Chr(34) + ": " + Chr(34) + "NORMAL" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "duration" + Chr(34) + ": " + Chr(34) + "DAY" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "orderStrategyType" + Chr(34) + ": " + Chr(34) + "SINGLE" + Chr(34) + "," + Chr(10)
        cOS = cOS + "  " + Chr(34) + "orderLegCollection" + Chr(34) + ": [" + Chr(10)
        cOS = cOS + "    {" + Chr(10)
        cOS = cOS + "      " + Chr(34) + "instruction" + Chr(34) + ": " + Chr(34) + "SELL" + Chr(34) + "," + Chr(10)
        cOS = cOS + "      " + Chr(34) + "quantity" + Chr(34) + ": " + Trim(Str(Abs(nQty))) + "," + Chr(10)
        cOS = cOS + "      " + Chr(34) + "instrument" + Chr(34) + ": {" + Chr(10)
        cOS = cOS + "        " + Chr(34) + "symbol" + Chr(34) + ": " + Chr(34) + cStock + Chr(34) + "," + Chr(10)
        cOS = cOS + "        " + Chr(34) + "assetType" + Chr(34) + ": " + Chr(34) + "EQUITY" + Chr(34) + Chr(10)
        cOS = cOS + "      }" + Chr(10)
        cOS = cOS + "    }" + Chr(10)
        cOS = cOS + "  ]" + Chr(10)
        cOS = cOS + "}"
    
    End If
     
    cURL_EndPoint = "https://api.tdameritrade.com/v1/accounts/" + cAccountNumber + "/orders"
        
    cPostData = cOS
    
    Set oHttp = New MSXML2.XMLHTTP60
    Call oHttp.Open("POST", cURL_EndPoint, False)
    oHttp.setRequestHeader "Content-Type", "application/json"
    oHttp.setRequestHeader "Authorization", "Bearer " + cAccessToken
    oHttp.setRequestHeader "Host", "api.tdameritrade.com"

    Call oHttp.Send(cPostData)
    
    httpGet = oHttp.responseText
    
    Set oHttp = Nothing

    ThisWorkbook.Sheets("Stocks").Range("E" + Trim(Str(nPosition))).Value = "EXECUTED"
    
End Function

Sub mcrGetPositions()
    GetPositions
End Sub
Function GetPositions()
Dim cCustomerKey As String
Dim cAccountNumber As String
Dim cAccessToken As String
Dim x As Integer
Dim x2 As Integer

Dim oHttp As Object
Dim httpGet As String
Dim parsetext As String
Dim cPostData As String
Dim cURL_EndPoint As String
Dim cSymbol As String
Dim nAveragePrice As Double
Dim nLongQuantity As Double
Dim nShortQuantity As Double
Dim nQty As Double
Dim nCost As Double
Dim cLine As String
Dim nValue As Double
Dim nDayPL As Double

    If Not GetTokens Then
        Exit Function
    End If

    cAccountNumber = ThisWorkbook.Sheets("Settings").Range("B2").Value
    cAccessToken = ThisWorkbook.Sheets("Settings").Range("B3").Value
    cCustomerKey = ThisWorkbook.Sheets("Settings").Range("B5").Value

    cURL_EndPoint = "https://api.tdameritrade.com/v1/accounts/" + cAccountNumber + "?apikey=" + cCustomerKey + "&fields=positions"
    
    cPostData = "Bearer " + cAccessToken
        
    Set oHttp = New MSXML2.XMLHTTP60
    Call oHttp.Open("GET", cURL_EndPoint, False)
    oHttp.setRequestHeader "Authorization", cPostData
    oHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    oHttp.setRequestHeader "Host", "api.tdameritrade.com"
    
    Call oHttp.Send(cPostData)
    
    httpGet = oHttp.responseText
    
    Set dic = ParseJSON(httpGet)
    
    x2 = 6
    
    ThisWorkbook.Sheets("Portfolio").Range("A6:E100").Clear
    
    For x = 1 To 100
        cSymbol = dic("obj.securitiesAccount.positions(" + Trim(Str(x - 1)) + ").instrument.symbol")
        If cSymbol = "" Then
            x = 100
        Else
            nAveragePrice = dic("obj.securitiesAccount.positions(" + Trim(Str(x - 1)) + ").averagePrice")
            nDayPL = dic("obj.securitiesAccount.positions(" + Trim(Str(x - 1)) + ").currentDayProfitLoss")
            nLongQuantity = dic("obj.securitiesAccount.positions(" + Trim(Str(x - 1)) + ").longQuantity")
            nShortQuantity = dic("obj.securitiesAccount.positions(" + Trim(Str(x - 1)) + ").shortQuantity")
            nQty = nLongQuantity + nShortQuantity
            nValue = nAveragePrice * nQty
    
            ThisWorkbook.Sheets("Portfolio").Range("A" + Trim(Str(x2))).Value = cSymbol
            ThisWorkbook.Sheets("Portfolio").Range("B" + Trim(Str(x2))).Value = nAveragePrice
            ThisWorkbook.Sheets("Portfolio").Range("C" + Trim(Str(x2))).Value = nQty
            ThisWorkbook.Sheets("Portfolio").Range("D" + Trim(Str(x2))).Value = nValue
            ThisWorkbook.Sheets("Portfolio").Range("E" + Trim(Str(x2))).Value = nDayPL
            x2 = x2 + 1
        End If
        
    Next x
    
    ThisWorkbook.Sheets("Portfolio").Range("B6:B" + Trim(Str(x2))).Select
    Selection.Style = "Currency"
    ThisWorkbook.Sheets("Portfolio").Range("D6:E" + Trim(Str(x2))).Select
    Selection.Style = "Currency"
    Range("A6:E" + Trim(Str(x2))).Select
    ActiveWorkbook.Worksheets("Portfolio").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Portfolio").Sort.SortFields.Add key:=Range( _
        "A6:A" + Trim(Str(x2))), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Portfolio").Sort
        .SetRange Range("A6:E" + Trim(Str(x2)))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ThisWorkbook.Sheets("Portfolio").Range("D6:D" + Trim(Str(x2))).Select
    ThisWorkbook.Sheets("Portfolio").Range("D" + Trim(Str(x2 + 1))).Activate
    ActiveCell.FormulaR1C1 = "=SUM(R[-" + Trim(Str(x2 - 6)) + "]C:R[-1]C)"
    
    ThisWorkbook.Sheets("Portfolio").Range("E6:E" + Trim(Str(x2))).Select
    ThisWorkbook.Sheets("Portfolio").Range("E" + Trim(Str(x2 + 1))).Activate
    ActiveCell.FormulaR1C1 = "=SUM(R[-" + Trim(Str(x2 - 6)) + "]C:R[-1]C)"

    
End Function
Sub mcrGetQuotes()
Dim x As Integer
Dim cStock As String
Dim nQty As Integer
    
    'Loop through column A and purchase any valid stock symbols with a quantity <> 0
    For x = 5 To 100
        cStock = ThisWorkbook.Sheets("Stocks").Range("A" + Trim(Str(x))).Value
        If Len(cStock) > 1 And Len(cStock) < 6 Then
            GetQuote cStock, x
            ThisWorkbook.Sheets("Stocks").Range("D" + Trim(Str(x))).Formula = "=B" + Trim(Str(x)) + "*C" + Trim(Str(x))
        End If
    Next x
    
    ThisWorkbook.Sheets("Stocks").Range("B5:B100").Select
    Selection.Style = "Currency"
    ThisWorkbook.Sheets("Stocks").Range("D5:D100").Select
    Selection.Style = "Currency"

End Sub
Function GetQuote(cSymbol As String, nPosition As Integer) As Double
Dim cCustomerKey As String
Dim cAccountNumber As String
Dim cAccessToken As String
    
Dim oHttp As Object
Dim httpGet As String
Dim parsetext As String
Dim cURL_EndPoint As String
Dim x As Integer
Dim cPostData As String
Dim nAskPrice As Double

    If Not GetTokens Then
        ThisWorkbook.Sheets("Stocks").Range("E" + Trim(Str(nPosition))).Value = "QUOTE ERROR!"
        Exit Function
    Else
        ThisWorkbook.Sheets("Stocks").Range("E" + Trim(Str(nPosition))).Value = ""
    End If
 
    cAccountNumber = ThisWorkbook.Sheets("Settings").Range("B2").Value
    cAccessToken = ThisWorkbook.Sheets("Settings").Range("B3").Value
    cCustomerKey = ThisWorkbook.Sheets("Settings").Range("B5").Value
    
    cURL_EndPoint = "https://api.tdameritrade.com/v1/marketdata/" + cSymbol + "/quotes?" & _
        "apikey=" + cCustomerKey
        
    cPostData = "Bearer " + cAccessToken
    
    Set oHttp = New MSXML2.XMLHTTP60
    Call oHttp.Open("GET", cURL_EndPoint, False)
    oHttp.setRequestHeader "Authorization", cPostData
    oHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    oHttp.setRequestHeader "Host", "api.tdameritrade.com"
   
        
    Call oHttp.Send(cPostData)
    
    httpGet = oHttp.responseText
    
    Set dic = ParseJSON(httpGet)

    Set oHttp = Nothing
    
    nAskPrice = dic("obj." + cSymbol + ".askPrice")
    
    ThisWorkbook.Sheets("Stocks").Range("B" + Trim(Str(nPosition))).Value = nAskPrice
    
    

End Function

Function GetTokens() As Boolean
 
 Dim oHttp As Object
 Dim httpGet As String
 Dim parsetext As String
 Dim cEndPoint As String
 Dim cRefreshToken As String
 Dim cCustomerKey As String
 Dim cAccessToken As String
 Dim lNeedRefresh As Boolean
 Dim lNeedAccess As Boolean
 Dim cRefreshTokenDate As String
 Dim cAccessTokenDate As String
 Dim nElapsedMins As Long
 Dim cPostData As String
 Dim nStart As Integer
 Dim nEnd As Integer
 
    GetTokens = True
    
    cRefreshTokenDate = ""
    cAccessTokenDate = ""
 
    cRefreshTokenDate = ThisWorkbook.Sheets("Settings").Range("B7").Value
    If Len(cRefreshTokenDate) < 1 Then
        ThisWorkbook.Sheets("Settings").Range("B7").Value = Date
        lNeedRefresh = True
    Else
        If DateDiff("d", cRefreshTokenDate, Date) > 85 Then
            lNeedRefresh = True
        Else
            lNeedRefresh = False
        End If
    End If
    
    cAccessTokenDate = ThisWorkbook.Sheets("Settings").Range("B6").Value
    If Len(cAccessTokenDate) < 1 Then
        ThisWorkbook.Sheets("Settings").Range("B6").Value = Now()
        lNeedAccess = True
    Else
        nElapsedMins = DateDiff("n", cAccessTokenDate, Now)
        If nElapsedMins > 25 Then
            lNeedAccess = True
        Else
            lNeedAccess = False
        End If
    End If
    
    If Not lNeedRefresh And Not lNeedAccess Then Exit Function
    
    cCustomerKey = ThisWorkbook.Sheets("Settings").Range("B5").Value
    
    If Not lNeedRefresh Then 'Access token only
    
        cRefreshToken = ThisWorkbook.Sheets("Settings").Range("B4").Value
              
        cEndPoint = "https://api.tdameritrade.com/v1/oauth2/token"
           
        cPostData = "grant_type=refresh_token&" & _
            "refresh_token=" + cRefreshToken + "&" & _
            "code=&" & _
            "client_id=" + cCustomerKey + "&" & _
            "redirect_uri=http%3A%2F%2F127.0.0.1"

        Set oHttp = New MSXML2.XMLHTTP60
        Call oHttp.Open("POST", cEndPoint, False)
        oHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        oHttp.setRequestHeader "Host", "api.tdameritrade.com"
        
        Call oHttp.Send(cPostData)
        
        httpGet = oHttp.responseText
        
        Set oHttp = Nothing
        
        If InStr(1, httpGet, "invalid_grant") > 0 Or InStr(1, httpGet, "limit reached") > 0 Then
            MsgBox httpGet
            GetTokens = False
        Else
            
            nStart = InStr(1, httpGet, "access_token") + 17
            nEnd = InStr(1, httpGet, Chr(34) + ",")
            
            cAccessToken = Left(httpGet, nEnd - 1)
            cAccessToken = Right(cAccessToken, Len(cAccessToken) - nStart + 1)
            
            ThisWorkbook.Sheets("Settings").Range("B3").Value = cAccessToken
            ThisWorkbook.Sheets("Settings").Range("B6").Value = Now()
        End If
        
    Else 'Get Refresh and Access tokens
    
        cRefreshToken = ThisWorkbook.Sheets("Settings").Range("B4").Value
              
        cEndPoint = "https://api.tdameritrade.com/v1/oauth2/token"
           
        cPostData = "grant_type=refresh_token&" & _
            "refresh_token=" + cRefreshToken + "&" & _
            "access_type=offline&" & _
            "code=&" & _
            "client_id=" + cCustomerKey + "&" & _
            "redirect_uri=http%3A%2F%2F127.0.0.1"
        
        Set oHttp = New MSXML2.XMLHTTP60
        Call oHttp.Open("POST", cEndPoint, False)
        oHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        oHttp.setRequestHeader "Host", "api.tdameritrade.com"
        
        Call oHttp.Send(cPostData)
        
        httpGet = oHttp.responseText
        
        Set oHttp = Nothing
        
        If InStr(1, httpGet, "invalid_grant") > 0 Then
            MsgBox httpGet
            GetTokens = False
        Else
            
            nStart = InStr(1, httpGet, "access_token") + 17
            nEnd = InStr(1, httpGet, Chr(34) + ",")
            
            cAccessToken = Left(httpGet, nEnd - 1)
            cAccessToken = Right(cAccessToken, Len(cAccessToken) - nStart + 1)
           
            nStart = InStr(1, httpGet, "refresh_token") + 18
            nEnd = InStr(nStart, httpGet, Chr(34) + ",")
            
            cRefreshToken = Left(httpGet, nEnd - 1)
            cRefreshToken = Right(cRefreshToken, Len(cRefreshToken) - nStart + 1)
            
            ThisWorkbook.Sheets("Settings").Range("B3").Value = cAccessToken
            ThisWorkbook.Sheets("Settings").Range("B6").Value = Now()
            ThisWorkbook.Sheets("Settings").Range("B4").Value = cRefreshToken
            ThisWorkbook.Sheets("Settings").Range("B7").Value = Date

    
        End If
    
    
    End If
    
    
End Function